home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / xlib.lha / xlib / orbit_fix.t < prev    next >
Text File  |  1990-06-01  |  4KB  |  97 lines
  1. (herald orbit_fix)
  2.  
  3. (define (generate-foreign-call node)
  4.   (destructure (((#f foreign rep-list value-rep . args) (call-args node)))
  5.     (emit risc/store 'l sp (reg-offset nil-reg slink/saved-sp))
  6.     (emit risc/store 'l ssp (reg-offset nil-reg slink/saved-ssp))
  7.     (emit risc/store 'l crit-reg (reg-offset nil-reg slink/saved-crit))
  8.     (let* ((rep-list (map cadr (leaf-value rep-list)))
  9.        (replen (length rep-list))
  10.        (bump-bytes (+ (* (max 0 (- replen  4)) 4) 24))) ;24=base stack frame
  11.       (emit risc/sub (machine-num bump-bytes) sSP sSP)
  12.       (emit risc/store 'l link-reg (reg-offset ssp (fx- bump-bytes 4)))
  13.       (cond ((every? (lambda (x) (neq? x 'rep/double)) rep-list)
  14.          (receive (reg-args stack-args)
  15.            (if (fx<= replen 4)
  16.            (return rep-list '())
  17.            (return (nthcdr rep-list (fx- replen 4))
  18.                (reverse (sublist rep-list 0 (fx- replen 4)))))
  19.            (do ((reps stack-args (cdr reps))
  20.             (i 16 (fx+ i 4))
  21.             (in A5 (fx+ in 1)))
  22.            ((null? reps)
  23.             (do ((in (length reg-args) (fx- in 1))
  24.              (out (fx+ (length reg-args) 1) (fx- out 1))
  25.              (reps reg-args (cdr reps)))
  26.             ((null? reps))
  27.               (pointer->rep in out (car reps))
  28.               (lock out)))
  29.          (cond ((fx< in AN)
  30.             (pointer->rep in AN (car reps)))
  31.                (else
  32.             (emit risc/load 'l 
  33.               (reg-offset extra-args (+ (* (- in AN) 8) %%car))
  34.               parassign-extra)
  35.             (pointer->rep parassign-extra AN (car reps))))
  36.          (emit risc/store 'l AN (reg-offset ssp i)))))
  37.         ((or (any? (lambda (x) (neq? x 'rep/double)) rep-list)
  38.          (fx> (length rep-list) 2))
  39.          (bug "Can't deal with this mix of float reps"))
  40.         ((null? (cdr rep-list))
  41.          (asemit mips/fload `((reg-offset ,A1 2) 12))
  42.          (asemit mips/fload `((reg-offset ,A1 6) 13)))
  43.         (else
  44.          (asemit mips/fload `((reg-offset ,A1 2) 12))
  45.          (asemit mips/fload `((reg-offset ,A1 6) 13))
  46.          (asemit mips/fload `((reg-offset ,A2 2) 14))
  47.          (asemit mips/fload `((reg-offset ,A2 6) 15))))
  48.       (generate-move (lookup-value node (leaf-value foreign)) an)
  49.       (emit risc/load 'l (reg-offset an 6) an)
  50.       (emit mips/jalr an link-reg)
  51.       (emit mips/noop)
  52.       (generate-move zero extra-args)
  53.       (generate-move zero extra)
  54.       (do ((i a2 (fx+ i 1)))
  55.       ((fx> i an+1))
  56.     (generate-move zero i))
  57.       (emit risc/load 'l (reg-offset ssp (fx- bump-bytes 4)) link-reg)
  58.       (emit risc/add (machine-num bump-bytes) sSP sSP))
  59.     (case (leaf-value value-rep)
  60.       ((rep/undefined ignore)
  61.        (generate-move zero a1)
  62.        (generate-move zero p))       
  63.       ((rep/double)
  64.        (generate-move zero p)
  65.        (generate-move (machine-num header/double-float) AN)
  66.        (generate-move (machine-num 8) scratch)       
  67.        (generate-slink-call slink/make-extend)
  68.        (asemit mips/fstore `(1 (reg-offset ,AN 6))) ;register $f1
  69.        (asemit mips/fstore `(0 (reg-offset ,AN 2))) ;register $f0
  70.        (generate-move AN A1))                         ; return consed flonum
  71.       (else
  72.        (rep->pointer P A1  (leaf-value value-rep)) ;P = register $2
  73.        (generate-move zero p))))
  74.     (emit risc/store 'l zero (reg-offset nil-reg slink/saved-ssp)))
  75.  
  76.  
  77. (define (pointer->rep from to rep)
  78.   (case rep
  79.     ((rep/pointer) (generate-move from to))
  80.     ((rep/extend) (emit risc/add (machine-num 2) from to))
  81.     ((rep/c-pointer) 
  82.      (emit risc/add (machine-num 2) from to)
  83.      (emit risc/srl (machine-num 2) to to) 
  84.      (emit risc/sll (machine-num 2) to to))
  85.     ((rep/string)
  86.      (emit risc/load 'l (reg-offset from 2) vector)
  87.      (emit risc/load 'l (reg-offset from 6) scratch)
  88.      (emit risc/add scratch vector vector)
  89.      (emit risc/add (machine-num 2) vector to))
  90.     ((rep/char)
  91.      (emit risc/srl (machine-num 8) from to))
  92.     (else
  93.      (emit risc/sra (machine-num 2) from to))))
  94.  
  95.  
  96.      
  97.